home *** CD-ROM | disk | FTP | other *** search
/ Scene 96 / Scene 96 International Edition (Zyklop Software) (Disc 2) (1997).iso / misc / coding / vgacodng / part02_a.pas < prev    next >
Pascal/Delphi Source File  |  1996-11-22  |  2KB  |  127 lines
  1. {$G+}
  2. program Fading;
  3.  
  4. uses crt;
  5.  
  6. var Pal   : array[0..255,1..3] of byte;
  7.     n1,n2 : word;
  8.  
  9. procedure PutPixel(x,y:integer;col:byte);assembler;
  10. asm
  11.   mov     ax,0A000h
  12.   mov     es,ax
  13.   mov     bx,[x]
  14.   mov     dx,[y]
  15.   mov     di,bx
  16.   mov     bx,dx
  17.   shl     dx,8
  18.   shl     bx,6
  19.   add     dx,bx
  20.   add     di,dx
  21.   mov     al,[col]
  22.   stosb                          
  23. end;
  24.  
  25. procedure SetPal(col,R,G,B:byte);
  26. begin
  27.   port[$3C8] := col;
  28.   port[$3C9] := R;
  29.   port[$3C9] := G;
  30.   port[$3C9] := B;
  31. end;
  32.  
  33. procedure GetPal(col:byte;var R,G,B:byte);
  34. begin
  35.   port[$3C7] := col;
  36.   R := port[$3C9];
  37.   G := port[$3C9];
  38.   B := port[$3C9];
  39. end;
  40.  
  41. procedure WaitRetrace;assembler;
  42. asm
  43.   mov     dx,3DAh
  44. @x:
  45.   in      al,dx
  46.   test    al,08h
  47.   jnz     @x
  48. @y:
  49.   in      al,dx
  50.   test    al,08h
  51.   jz      @y
  52. end;
  53.  
  54. procedure BlackPal;
  55. var n : byte;
  56.  
  57. begin
  58.   WaitRetrace;
  59.   for n := 0 to 255 do SetPal(n,0,0,0);
  60. end;
  61.  
  62. procedure GrabPal;
  63. var n : byte;
  64.  
  65. begin
  66.   for n := 0 to 255 do GetPal(n,Pal[n,1],Pal[n,2],Pal[n,3]);
  67. end;
  68.  
  69. procedure FadeUp;
  70. var n1,n2 : byte;
  71.     Tmp   : array[1..3] of byte;
  72.  
  73. begin
  74.   for n1 := 1 to 64 do begin
  75.     WaitRetrace;
  76.     For n2 := 0 to 255 do begin
  77.       GetPal(n2,Tmp[1],Tmp[2],Tmp[3]);
  78.       if Tmp[1] < Pal[n2,1] then inc (Tmp[1]);
  79.       if Tmp[2] < Pal[n2,2] then inc (Tmp[2]);
  80.       if Tmp[3] < Pal[n2,3] then inc (Tmp[3]);
  81.       SetPal(n2,Tmp[1],Tmp[2],Tmp[3]);
  82.     end;
  83.   end;
  84. end;
  85.  
  86. procedure FadeDown;
  87. var n1,n2 : byte;
  88.     Tmp   : array[1..3] of byte;
  89.  
  90. begin
  91.   for n1 := 1 to 64 do begin
  92.     WaitRetrace;
  93.     For n2 := 0 to 255 do begin
  94.       GetPal(n2,Tmp[1],Tmp[2],Tmp[3]);
  95.       if Tmp[1] > 0 then dec (Tmp[1]);
  96.       if Tmp[2] > 0 then dec (Tmp[2]);
  97.       if Tmp[3] > 0 then dec (Tmp[3]);
  98.       SetPal(n2,Tmp[1],Tmp[2],Tmp[3]);
  99.     end;
  100.   end;
  101. end;
  102.  
  103. procedure SetMCGAMode;assembler;
  104. asm
  105.   mov     ax,13h
  106.   int     10h
  107. end;
  108.  
  109. procedure SetTextMode;assembler;
  110. asm
  111.   mov     ax,3
  112.   int     10h
  113. end;
  114.  
  115.  
  116. begin
  117.   SetMCGAMode;
  118.   GrabPal;
  119.   BlackPal;
  120.   for n1 := 0 to 319 do
  121.     for n2 := 0 to 199 do PutPixel(n1,n2,random(256));
  122.   FadeUp;
  123.   readkey;
  124.   FadeDown;
  125.   SetTextMode;
  126. end.
  127.